;-*- Mode:LISP; Package:ZWEI; Base:8. -*-
;;; Balance Directories Editor, by HANSON -- feel free to use it.

;;;; BDIRED Lines

(DEFSUBST BDIRED-CURRENT-LINE (STREAM)
  (BP-LINE (SEND STREAM ':READ-BP)))

(DEFSUBST BDIRED-PREVIOUS-LINE (STREAM)
  (LINE-PREVIOUS (BDIRED-CURRENT-LINE STREAM)))

(DEFSUBST BDIRED-NEXT-LINE (STREAM)
  (LINE-NEXT (BDIRED-CURRENT-LINE STREAM)))

(DEFSUBST PUT-LINE (LINE ITEM KEY)
  (PUTPROP (LOCF (LINE-PLIST LINE)) ITEM KEY))

(DEFSUBST GET-LINE (LINE KEY)
  (GET (LOCF (LINE-PLIST LINE)) KEY))

(DEFUN BDIRED-DELETE-LINE (FIRST-LINE &OPTIONAL LAST-LINE)
  (IF (NULL LAST-LINE) (SETQ LAST-LINE FIRST-LINE))
  (WITH-READ-ONLY-SUPPRESSED (*INTERVAL*)
    (DELETE-INTERVAL (BEG-LINE (CREATE-BP FIRST-LINE 0) 0)
                     (BEG-LINE (CREATE-BP LAST-LINE 0) 1)
                     T)))

;;; Line CFILE.

(DEFUN BDIRED-LIST-CFILE (CFILE STREAM)
  (FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* CFILE STREAM)
  (LET ((LINE (BDIRED-PREVIOUS-LINE STREAM)))
    (SETF (LINE-PLIST LINE) (CONS ':CFILE CFILE))
    LINE))


(DEFSUBST BDIRED-LINE-CFILE (LINE)
  (GET (LOCF (LINE-PLIST LINE)) :CFILE))

;;;; BDIRED Buffers

;(DEFSUBST BDIRED-ALTERNATE-PATHNAME (BUFFER)
;  (FOURTH (BUFFER-FILE-ID BUFFER)))

(DEFSUBST BDIRED-ALTERNATE-PATHNAME (BUFFER)
  (GET (LOCF (NODE-PROPERTY-LIST BUFFER)) ':ALTERNATE-PATHNAME))

(DEFSUBST UPDATE-BDIRED-BUFFER-PATHNAMES (BUFFER PATHNAME1 PATHNAME2)
  (SETF (BUFFER-PATHNAME BUFFER) PATHNAME1)
  (SETF (BDIRED-ALTERNATE-PATHNAME BUFFER) PATHNAME2))

(DEFUN FIND-OR-CREATE-BDIRED-BUFFER (PATHNAME1 PATHNAME2)
  (LET ((BUFFER (FUNCALL-SELF ':FIND-SPECIAL-BUFFER ':BDIRED
                              T "BDired")))
    (IF (NULL BUFFER) (ERROR "Cannot find BDIRED buffer" ()))
    (UPDATE-BDIRED-BUFFER-PATHNAMES BUFFER PATHNAME1 PATHNAME2)
    BUFFER))

;;;; Pathname Stuff

;(DEFUN BDIRED-READ-DIRECTORY-STRING (PROMPT PATHNAME)
;  (LET ((*READING-PATHNAME-DEFAULTS* PATHNAME)
;       (*READING-PATHNAME-SPECIAL-TYPE* (FS:PATHNAME-TYPE PATHNAME))
;       (*READING-PATHNAME-SPECIAL-VERSION* (FS:PATHNAME-VERSION PATHNAME))
;       (*READING-PATHNAME-DIRECTION* ':READ)
;       (*READING-PATHNAME-LAST-NAME-TYPED* *LAST-FILE-NAME-TYPED*))
;    (MULTIPLE-VALUE-BIND (NIL NIL INTERVAL)
;       (EDIT-IN-MINI-BUFFER *PATHNAME-READING-COMTAB* NIL NIL
;                            (LIST (FORMAT NIL "~A (Default is ~A)" PROMPT PATHNAME)
;                                  '(:RIGHT-FLUSH " (Completion)")))
;      (STRING-INTERVAL INTERVAL))))

;(DEFUN BDIRED-READ-DIRECTORY-NAME (PROMPT PATHNAME)
;  (LET ((INTERVAL (BDIRED-READ-DIRECTORY-STRING PROMPT PATHNAME)))
;    (COND ((EQUAL INTERVAL "")
;          PATHNAME)
;         (T
;          (SETQ *LAST-FILE-NAME-TYPED* INTERVAL)
;          (FS:MERGE-PATHNAME-DEFAULTS INTERVAL PATHNAME NIL NIL)))))

;;;; Top Level

(DEFVAR *BDIRED-PATHNAME1-NAME* :UNBOUND
  "Pathname of active BDIRED buffer")

(DEFVAR *BDIRED-PATHNAME2-NAME* :UNBOUND
  "Alternate pathname of active BDIRED buffer")

(DEFMAJOR COM-BDIRED-MODE BDIRED-MODE "BDired"
          "Setup for editing directory differences" ()
  (PROGN                                        ;Due to ZWEI inversion lossage.
  (IF (TYPEP *INTERVAL* 'FILE-BUFFER)
      (LET ((PATHNAME1 (BUFFER-PATHNAME *INTERVAL*))
            (PATHNAME2 (BDIRED-ALTERNATE-PATHNAME *INTERVAL*)))
        (IF (NOT (NULL PATHNAME1))
            (SETQ *BDIRED-PATHNAME1-NAME* (STRING PATHNAME1)))
        (IF (NOT (NULL PATHNAME2))
            (SETQ *BDIRED-PATHNAME2-NAME* (STRING PATHNAME2))))))
  (SET-COMTAB *MODE-COMTAB*
              '(#/SP COM-DOWN-REAL-LINE
                #/= COM-DIRED-SRCCOM
                #/? COM-BDIRED-DOCUMENTATION
                #/HELP COM-BDIRED-DOCUMENTATION
                #/C COM-DIRED-COPY
                #/c (0 #/C)
                ;#/I COM-BDIRED-RESOLVE-INCONSISTENCY
                ;#/i (0 #/I)
                #/P com-bdired-print-transfer
                #/p (0 #/P)
                #/Q COM-BDIRED-EXIT
                #/q (0 #/Q)
                #/R COM-DIRED-RENAME
                #/r (0 #/R)
                #/T COM-BDIRED-TRANSFER
                #/t (0 #/T)
                #/U COM-BDIRED-UNMARK
                #/u (0 #/U)
                #/V COM-DIRED-VIEW-FILE
                #/v (0 #/V)
                #/RUBOUT COM-BDIRED-REVERSE-UNMARK
                #/ABORT COM-BDIRED-ABORT
                #/END COM-BDIRED-EXIT)
              '())
  (SETQ *MODE-LINE-LIST*
        (APPEND *MODE-LINE-LIST*
                '("  " *BDIRED-PATHNAME1-NAME*
                  "  " *BDIRED-PATHNAME2-NAME*
                  "  (Q to exit)"))))

(DEFUN (BDIRED-MODE PATHNAME-DEFAULTING-FUNCTION) (IGNORE BUFFER)
  (AND (EQ BUFFER *INTERVAL*)
       (DONT-OPTIMIZE (DIRED-LINE-PATHNAME (BP-LINE (POINT))))))

(DEFCOM COM-BDIRED "Edit the differences between two directories." ()
  (KILL-NEW-BUFFER-ON-ABORT (*INTERVAL*)
    (LET* ((DEFAULT (SEND (DEFAULT-PATHNAME) ':NEW-PATHNAME
                          ':NAME NIL
                          ':TYPE NIL
                          ':VERSION NIL))
           (PATHNAME1 (READ-DIRECTORY-NAME "Balance directory" DEFAULT)))
      (BDIRECTORY-EDIT
        PATHNAME1
        (READ-DIRECTORY-NAME (FORMAT NIL "Balance directory ~A with directory" PATHNAME1)
                             PATHNAME1)))))

(DEFUN BDIRECTORY-EDIT (PATHNAME1 PATHNAME2)
  "Enter the balance directories editor on directories PATHNAME1 and PATHNAME2.
In ZMACS, this creates a BDIRED buffer and reads the differences into it,
making it the current buffer."
  (LET ((*INTERVAL* (FIND-OR-CREATE-BDIRED-BUFFER PATHNAME1 PATHNAME2)))
    (MAKE-BUFFER-READ-ONLY *INTERVAL*)
    (COM-BDIRED-MODE)
    (BDIRED-INITIALIZE-BUFFER *INTERVAL* PATHNAME1 PATHNAME2)
    DIS-TEXT))

;;;; BDIRED Buffer Initialization

(DEFPROP BDIRED-MODE BDIRECTORY-EDIT-REVERT MAJOR-MODE-REVERT-FUNCTION)

(DEFUN BDIRECTORY-EDIT-REVERT (BUFFER PATHNAME &OPTIONAL IGNORE SELECT-FLAG IGNORE)
  "Revert a BDIRED buffer."

  (BDIRED-INITIALIZE-BUFFER BUFFER
                            PATHNAME
                            (BDIRED-ALTERNATE-PATHNAME BUFFER)
                            SELECT-FLAG))

(DEFUN BDIRED-INITIALIZE-BUFFER (BUFFER PATHNAME1 PATHNAME2 &OPTIONAL SELECT-FLAG)
  "Initialize a BDIRED buffer."

  (WITH-READ-ONLY-SUPPRESSED (BUFFER)
    (LET ((*BATCH-UNDO-SAVE* T)
          (SELECTED-P (EQ BUFFER *INTERVAL*))
          (*INTERVAL* BUFFER)
          (DIR1 (FS:CREATE-CDIRECTORY PATHNAME1 '() T))
          (DIR2 (FS:CREATE-CDIRECTORY PATHNAME2 '() T)))
      ;; What directories did we ultimately read?  Maybe the user corrected an error.
      (SETQ PATHNAME1 (FS:CDIRECTORY-PATHNAME DIR1))
      (SETQ PATHNAME2 (FS:CDIRECTORY-PATHNAME DIR2))
      (UPDATE-BDIRED-BUFFER-PATHNAMES BUFFER PATHNAME1 PATHNAME2)
      (FS:COMPARE-CDIRECTORIES DIR1 DIR2)
      (DELETE-INTERVAL BUFFER)
      (DISCARD-UNDO-INFORMATION BUFFER)
      (IF SELECTED-P
          (SETQ *BDIRED-PATHNAME1-NAME* (FUNCALL PATHNAME1 ':STRING-FOR-PRINTING)
                *BDIRED-PATHNAME2-NAME* (FUNCALL PATHNAME2 ':STRING-FOR-PRINTING)))
      (LET ((STREAM (INTERVAL-STREAM-INTO-BP (INTERVAL-FIRST-BP BUFFER))))
        (BDIRED-INSERT-DIRECTORY DIR1 STREAM DIR2)
        (SEND STREAM ':TYO #/CR)
        (BDIRED-INSERT-DIRECTORY DIR2 STREAM DIR1))
      (LET ((FIRST-LINE (BP-LINE (INTERVAL-FIRST-BP BUFFER))))
        (PUT-LINE FIRST-LINE DIR1 'CDIRECTORY1)
        (PUT-LINE FIRST-LINE DIR2 'CDIRECTORY2)))
    (BDIRED-MARK-INITIAL-TRANSFERS))
  (IF SELECT-FLAG (MAKE-BUFFER-CURRENT BUFFER)))

(DEFUN BDIRED-INSERT-DIRECTORY (DIRECTORY STREAM ALTERNATE-DIRECTORY)
  (LET ((DIRLIST (FS:CDIRECTORY-LIST DIRECTORY))
        (PATHNAME (FS:CDIRECTORY-PATHNAME DIRECTORY)))
    (DOLIST (CFILE (CDR DIRLIST))
      (PUTPROP (FS:CFILE-PLIST CFILE) ALTERNATE-DIRECTORY ':ALTERNATE-DIRECTORY))
    (SEND STREAM ':STRING-OUT (SEND PATHNAME ':STRING-FOR-PRINTING))
    (SEND STREAM ':LINE-PUT ':DIRECTORY PATHNAME)
    (SEND STREAM ':TYO #/CR)
    (SEND *DIRECTORY-SINGLE-FILE-LISTER* (CAR DIRLIST) STREAM)
        ;hands to DIRED of a CDIRECTORY.  The :CFILE property of each line
        ; gets the CAR of the DIRLIST element.
    (BDIRED-INSERT-DIRLIST DIRLIST STREAM 0)))

(DEFUN BDIRED-INSERT-DIRLIST (DIRECTORY STREAM LEVEL)
; this is almost the same function as DIRED-INSERT-DIRECTORY, but it puts the CFILE
;  on the line as a CFILE property. The TRUENAME is also put on as the :PATHNAME property
;  for compatibility with DIRED commands.
  "Insert into a DIRED buffer lines describing the files in DIRECTORY.
DIRECTORY is a value returned by FS:DIRECTORY-LIST.
STREAM is a stream outputting into the DIRED buffer.
LEVEL is the depth in subdirectories of these files.
Returns the first inserted line that describes a file."
  ;; Mark all files that are the newest
  (DIRED-COMPUTE-GREATER-THANS (CDR DIRECTORY))
  (DO ((FILES DIRECTORY (CDR FILES))
       (FILE)
       (LINE) (FIRST-FILE-LINE))
      ((NULL FILES)
       FIRST-FILE-LINE)
    (SETQ FILE (CAR FILES))
    (UNLESS (NULL (FS:CFILE-TRUENAME FILE))
      (IF (GET FILE ':DIRECTORY)
          (LET ((STR (SEND (SEND (SEND (FS:CFILE-TRUENAME FILE)
                                       :NEW-PATHNAME :DEVICE NIL
                                                     ;; Get rid of the version iff
                                                     ;; this is the newest one.
                                                     :VERSION (IF (GET FILE :NEWEST)
                                                                  NIL
                                                                  (SEND (CAR FILE) :VERSION)))
                                 :PATHNAME-AS-DIRECTORY)
                           :STRING-FOR-DIRECTORY)))
            ;; STR has the string we want to print instead of the filename.
            ;; Replace (CAR FILE) with a phony "pathname" that will print as that string.
            (WITH-STACK-LIST* (FILE1 #'(LAMBDA (&REST IGNORE) STR) (CDR FILE))
              (FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* FILE1 STREAM)))
        (FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* FILE STREAM))
      (SETQ LINE (LINE-PREVIOUS (BP-LINE (SEND STREAM :READ-BP))))
      (INSERT-CHARS (CREATE-BP LINE 5) #/SPACE (* *DIRED-SUBDIRECTORY-INDENTATION* LEVEL))
      ;; Use lower-case "d" to mark already-deleted files.
      (IF (GET FILE ':DELETED)
          (SETF (CHAR LINE 0) #/d))
      (OR FIRST-FILE-LINE
          (SETQ FIRST-FILE-LINE LINE))
      (SETF (GETF (LINE-PLIST LINE) 'LEVEL) LEVEL)
      (LOOP FOR (PROP VAL) ON (CDR FILE) BY 'CDDR       ;transfer properties to dired line.
         DO (SETF (GETF (LINE-PLIST LINE) PROP) VAL))
      (SETF (GETF (LINE-PLIST LINE) ':CFILE) FILE)
      (SETF (GETF (LINE-PLIST LINE) ':PATHNAME) (CAR FILE))
      )))

;;;; Commands

(DEFCOM COM-BDIRED-EXIT "Exit from BDIRED, performing transfers that you have selected." ()
  (IF (BDIRED-PROCESS-FILES)
      (FUNCALL-SELF ':EXIT-SPECIAL-BUFFER T *INTERVAL*))
  DIS-BPS)

(DEFCOM COM-BDIRED-ABORT "Exit BDIRED, not transferring any files." ()
  (FUNCALL-SELF ':EXIT-SPECIAL-BUFFER T *INTERVAL*)
  DIS-BPS)

(DEFUN BDIRED-MAP-OVER-ALL-LINES (FUN)
  (DO ((LINE (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*))
             (LINE-NEXT LINE))
       (LAST-LINE (BP-LINE (INTERVAL-LAST-BP *INTERVAL*))))
      ((EQ LINE LAST-LINE))
    (FUNCALL FUN LINE)))

(DEFUN BDIRED-MARK-INITIAL-TRANSFERS ()
  (BDIRED-MAP-OVER-ALL-LINES #'BDIRED-MARK-INITIAL-TRANSFER))

(DEFUN BDIRED-MARK-INITIAL-TRANSFER (LINE)
  (COND ((NOT (NULL (FS:CFILE-TRANSFER-DESTINATIONS (BDIRED-LINE-CFILE LINE))))
         (MUNG-LINE LINE)
         (ASET #/T LINE 0))))

(DEFUN BDIRED-MARK-TRANSFER (CFILE)
  (FS:MARK-CFILE-FOR-TRANSFER CFILE
                              (GET (FS:CFILE-PLIST CFILE) ':ALTERNATE-DIRECTORY)))

(DEFUN BDIRED-UNMARK-TRANSFER (CFILE)
  (IF (NOT (NULL (FS:CFILE-TRANSFER-DESTINATIONS CFILE)))
      (SETF (FS:CFILE-TRANSFER-DESTINATIONS CFILE) '())))

(DEFCOM COM-BDIRED-PRINT-TRANSFER "Print intended transfers for file(s)." ()
  (DIRED-MAP-OVER-LINES *NUMERIC-ARG*
                        #'(LAMBDA (LINE)
                            (BDIRED-PRINT-TRANSFER (BDIRED-LINE-CFILE LINE)))))

(defun bdired-print-transfer (cfile)
  (let ((*print-circle* t))
    (print (fs:cfile-transfer-destinations cfile))))

(DEFUN BDIRED-PROCESS-FILES ()
  (LET ((TERMINAL-IO *TYPEIN-WINDOW*)
        (FIRST-LINE (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*))))
    (LET ((DIR1 (GET-LINE FIRST-LINE 'CDIRECTORY1))
          (DIR2 (GET-LINE FIRST-LINE 'CDIRECTORY2)))
      (FS:SETUP-CDIRECTORY-TRANSFER-MODE DIR1)
      (FS:SETUP-CDIRECTORY-TRANSFER-MODE DIR2)
      (FS:CDIRECTORY-TRANSFER DIR1)
      (FS:CDIRECTORY-TRANSFER DIR2)))
  T)

(DEFCOM COM-BDIRED-TRANSFER "Mark file(s) for transfer." ()
  (DIRED-MAP-OVER-LINES *NUMERIC-ARG*
                        #'(LAMBDA (LINE)
                            (MUNG-LINE LINE)
                            (ASET #/T LINE 0)
                            (BDIRED-MARK-TRANSFER (BDIRED-LINE-CFILE LINE)))))

(DEFCOM COM-BDIRED-UNMARK "Un-mark file(s) for transfer or other action." ()
  (DIRED-MAP-OVER-LINES (IF (AND (NOT *NUMERIC-ARG-P*)
                                 (OR (NOT (DIRED-LINE-PATHNAME (BP-LINE (POINT))))
                                     (EQ (BP-CHAR (BEG-LINE (POINT))) #/SP)))
                            -1
                            *NUMERIC-ARG*)
                        #'(LAMBDA (LINE)
                            (MUNG-LINE LINE)
                            (ASET #/SP LINE 0)
                            (BDIRED-UNMARK-TRANSFER (BDIRED-LINE-CFILE LINE)))))

(DEFCOM COM-BDIRED-REVERSE-UNMARK "Un-mark previous file(s) for transfer or other action." ()
  (SETQ *NUMERIC-ARG* (- *NUMERIC-ARG*))
  (COM-BDIRED-UNMARK))


(COMMENT                                        ;may want some of this later.

;;; An Inconsistency consists of two Cfiles and
;;; a group of consecutive Lines in a Buffer.

(DEFSTRUCT (INCONSISTENCY (:TYPE :NAMED-ARRAY) :CONC-NAME)
  CFILE1
  CFILE2
  FIRST-LINE
  LAST-LINE)

(DEFUN BDIRED-INSERT-INCONSISTENCY (CFILE1 CFILE2 STREAM)
  (LET* ((LINE1 (BDIRED-LIST-CFILE CFILE1 STREAM))
         (LINE2 (BDIRED-LIST-CFILE CFILE2 STREAM))
         (LINE3 (PROGN (SEND STREAM ':TYO #/CR)
                       (BDIRED-PREVIOUS-LINE STREAM)))
         (INCONSISTENCY (MAKE-INCONSISTENCY FIRST-LINE LINE1
                                            LAST-LINE LINE3
                                            CFILE1 CFILE1
                                            CFILE2 CFILE2)))
    (PUT-LINE LINE1 INCONSISTENCY 'BDIRED-INCONSISTENCY)
    (PUT-LINE LINE2 INCONSISTENCY 'BDIRED-INCONSISTENCY)
    (PUT-LINE LINE3 INCONSISTENCY 'BDIRED-INCONSISTENCY)
    LINE1))

(DEFSUBST BDIRED-DELETE-INCONSISTENCY (INCONSISTENCY)
  (BDIRED-DELETE-LINE (INCONSISTENCY-FIRST-LINE INCONSISTENCY)
                      (INCONSISTENCY-LAST-LINE INCONSISTENCY)))

(DEFSUBST RELATED-INCONSISTENCY (LINE)
  (GET-LINE LINE 'BDIRED-INCONSISTENCY))

(DEFUN INCONSISTENCY-RELATED-CFILE (INCONSISTENCY CFILE)
  (COND ((EQ CFILE (INCONSISTENCY-CFILE1 INCONSISTENCY))
         (INCONSISTENCY-CFILE2 INCONSISTENCY))
        ((EQ CFILE (INCONSISTENCY-CFILE2 INCONSISTENCY))
         (INCONSISTENCY-CFILE1 INCONSISTENCY))
        (T
         (ERROR "Cfile not element of Inconsistency"
                (LIST CFILE INCONSISTENCY)))))

(DEFCOM COM-BDIRED-RESOLVE-INCONSISTENCY
        "Alter the other file's version//creation date.
When pointing at one file of an inconsistency, alters the version//creation-date
information of the other file to match this file." ()
  (LET ((LINE (BP-LINE (POINT))))
    (LET ((CORRECT-CFILE (BDIRED-LINE-CFILE LINE))
          (INCONSISTENCY (OR (RELATED-INCONSISTENCY LINE)
                             (BARF "Not an inconsistency"))))
      (LET ((INCORRECT-CFILE (INCONSISTENCY-RELATED-CFILE INCONSISTENCY
                                                          CORRECT-CFILE)))
        (LET ((V1 (FS:CFILE-VERSION CORRECT-CFILE))
              (V2 (FS:CFILE-VERSION INCORRECT-CFILE))
              (CD1 (FS:CFILE-CREATION-DATE CORRECT-CFILE))
              (CD2 (FS:CFILE-CREATION-DATE INCORRECT-CFILE))
              (TRUENAME (FS:CFILE-TRUENAME INCORRECT-CFILE)))
          (IF (= V1 V2)
              (IF (NOT (= CD1 CD2))
                  (BDIRED-CHANGE-CREATION-DATE TRUENAME CD1))
              (IF (= CD1 CD2)
                  (BDIRED-CHANGE-VERSION TRUENAME V1)
                  (BDIRED-CHANGE-VERSION-AND-CREATION-DATE TRUENAME V1 CD1)))))
      (BDIRED-DELETE-INCONSISTENCY INCONSISTENCY)))
  DIS-TEXT)

(DEFUN BDIRED-CHANGE-CREATION-DATE (TRUENAME DATE)
  (WITH-OPEN-FILE (STREAM TRUENAME ':DIRECTION ':INPUT)
    (SEND STREAM ':CHANGE-PROPERTIES NIL ':CREATION-DATE DATE))
  (FORMAT *QUERY-IO* "~&Creation date of ~A changed to ~A"
          TRUENAME (TIME:PRINT-UNIVERSAL-TIME DATE NIL)))

(DEFUN BDIRED-CHANGE-VERSION (TRUENAME VERSION)
  (LET ((NEWNAME (SEND TRUENAME ':NEW-VERSION VERSION)))
    (WITH-OPEN-FILE (STREAM TRUENAME ':DIRECTION ':INPUT)
      (SEND STREAM ':RENAME NEWNAME))
    (FORMAT *QUERY-IO* "~&~A renamed to ~A" TRUENAME NEWNAME)))

(DEFUN BDIRED-CHANGE-VERSION-AND-CREATION-DATE (TRUENAME VERSION DATE)
  (LET ((NEWNAME (SEND TRUENAME ':NEW-VERSION VERSION)))
    (WITH-OPEN-FILE (STREAM TRUENAME ':DIRECTION ':INPUT)
      (SEND STREAM ':RENAME NEWNAME)
      (SEND STREAM ':CHANGE-PROPERTIES NIL ':CREATION-DATE DATE))
    (FORMAT *QUERY-IO* "~&~A renamed to ~A;~%creation date changed to ~A"
            TRUENAME NEWNAME (TIME:PRINT-UNIVERSAL-TIME DATE NIL))))
)

;;;; Documentation

(DEFCOM COM-BDIRED-DOCUMENTATION "Print various sorts of editor documentation" ()
  (LET ((*COM-DOCUMENTATION-ALIST*
          (CONS '(#/M COM-BDIRED-HELP) *COM-DOCUMENTATION-ALIST*)))
    (COM-DOCUMENTATION)))

(DEFCOM COM-BDIRED-HELP "Explain use of DIRED commands" ()
  (FORMAT T "You are in the balance directories editor.  The commands are:
        T       Mark the current file to be transferred.
        P       Mark the current file to be printed on the standard hardcopy device.
        U       Cancel any request marked on the current line, or else the line above.
        Rubout  Move up and cancel any request marked on that line.
        R       Rename this file.  You type the new filename in a mini buffer.
        C       Copy this file.  You type the new filename in a mini buffer.
        Space   Move to the next line.
          Above commands repeat with a numeric argument,
          backwards if the argument is negative.
        V       View current file.
        Q (or End)  Exit.  The remaining files in the transfer lists will be moved.
        Abort   Exit without performing any transfers.
        =       SRCCOM this file with the > version.
")
  DIS-NONE)
